00100	C  THIS PROGRAM(FUCOL.F4) CREATES FUNCTIONS FOR THE MUSIC PROGRAM
00200	C  USING 'SEG' OR 'SYNTH'.  UP TO 10 FUNCTIONS CAN BE STORED IN A
00300	C  SINGLE FILE.  ONCE CREATED, THE FUNCTIONS MAY BE CHANGED
00400	C  AND PUT BACK IN THE SAME FILE OR INTO A NEW ONE.
00500	C  NO MORE THAN 50 INPUTS FOR ONE FUNCTION!
00505	
00602	C TYPE 'C'(= CRUNCH)  FOR SPECIAL FEATURE SUBR TO COMBINE FUNCS 
00603	C ALREADY MADE.      [MULT, ADD, RETRO, INVRT, ADD CONSTANT ]
00610	
00611	C  SEG FUNCS MAY BE 'SMOOTHED' BUT THIS FEATURE AND 'CRUNCH' SHOULD 
00612	C  BE USED SPARINGLY AS ALL 512 WDS OF THE ARRAY MUST BE SAVED.  THIS
00613	C  CLUTTERS UP THE DSK.
00614	
00615	C  'Z' FOR "CHANGE OR FINISH?" WILL JUMP DIRECTLY TO "CRUNCH" MODE.
00700	C    BUT ONCE CHANGED BY 'CRUNCH' THIS UNSTORED ORIG. IS LOST.
00800	C'SP'(FOR "SEE")PLOTS ONE FUNC. (SA=PLOT ALL); 'SL' PUTS IT OUT ON
00805	C  THE LPT.
00810	
00900	C FOR EXPONENTIALS GET INTO 'SEG'.  TYPE 'X', DECAY FAC, N.  IF 
01000	C  N IS NON-ZERO THE FUNCTION WILL NOT! NORMALIZE (IE. NOT GO TO 0).
01100	C  AFTER A FILE HAS BEEN READ IN,
01150	C  THE DECAY FAC. IS THE NUM ALONGTHE SCALE(1-100) WHERE THE CURVE
01175	C  SEEMS TO TOUCH ZERO. (WILL ALWAYS HIT 0 AT END UNLESS N.NE.0.)
01180	
01200	C  <CR> FOR 'TYPE FILE' WILL HOLD ON TO IT.
01300	C  LOAD WITH -- WRIFUN,FUSUB,DFUEXP,SSS,LOOK.FAI (+RANFIL.MAC?)
01500		COMMON/S/H,AMP,CON,PH
01600		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
01700		1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
01800		COMMON FUNC(512),F2(512),K,I
01900		COMMON/LT/LPTY,JSEE
02000		DIMENSION RF(4)
02200	21	FORMAT(' C=CHANGE, F=FINISH '$)
02300	22	FORMAT(' NEW FUNC, EDIT, CRUNCH, DELETE, RENAME, SEE?   '$)
02400	23	FORMAT(' SEG OR SYNTH?   '$)
02600	25	FORMAT(' TYPE FILE NAME   '$)
02700	26	FORMAT(I3,') TYPE AMPL, STEP#  '$)
02800	C  'X' HERE WILL MAKE EXPON. FUNC.
02900	28	FORMAT(' 0=NORM,OR H,A,P,K   '$)
03000	280	FORMAT(
03100		1' UP TO 10 FUNCTIONS MAY BE STORED IN EACH FILE'/
03200		1' TYPE "B" TO BACKUP AT ANY TIME'//)
03300	30	FORMAT(8F)
03400	31	FORMAT(1XA5,A1,5A5/)
03600	35	FORMAT(1XA5,'IN FILE "',A5,'.DAT"'/)
03700	37	FORMAT(8F9.3)
03800	371	FORMAT(I3,') ',4F8.2)
03900	372	FORMAT(I,21F)
04000	38	FORMAT(2(A5,A1),23A2)
04300	40	FORMAT(11(A1,A3))
04400	41	FORMAT(' ADD TO AN EXISTING FILE?   '$)
04500	42	FORMAT(' WHICH FUNC?   '$)
04600	47	FORMAT(' C=CHNG, I=INSRT, D=DEL -- + LN# & CHNGS '$)
04700	48	FORMAT(' X,N(=DECAY FAC.) FOR XPONTLS')
04800	2281	TYPE 280
04900	281	KZ=0
05000		JSEE=0
05100		LPTY=5
05200	C   USED IN RELATIVE VECTOR ROUTINE
05300		Z=0
05400		EY=0
05500		ICUR=0
05600		XP=0
05650		KT=0
05700		FNUM=0
05800		OLD=0
05900		FNUM1=0
06000		TYPE 22
06100		ACCEPT 40,ON,P
06110		PLTALL=0
06155		IF(P.EQ.'A'.OR.P.EQ.'X')PLTALL=-1
06200	1281	IPLOT=0
06300	CC 7/74 COLGATE	IF(ON.EQ.'N'.OR.(ON.EQ.' '.AND.ONX.NE.'S'))GO TO 1000
06420		IF(ON.EQ.'N')GO TO 1000
06440		IF(ON.EQ.'E'.OR.ON.EQ.'R'.OR.ON.EQ.'D'
06470		1 .OR.ON.EQ.'C'.OR.ON.EQ.'S')GO TO 100
06500	CC 7/74 COLGATE	ON=ONX
06700	C ---OUT 7/74---  RETURNS FOR MORE "SEE"
06800	CC 7/74 COLGATE	GO TO 4281
06850		GO TO 281
06860	C  WON'T GO ON IF BLANK
06900	100	ONX=ON
07000		TYPE 25
07100		OLD=-1
07200		ACCEPT 38,FLNM1
07300		IF(FLNM1.EQ.' ')FLNM1=FLNM
07400		IF(FLNM1.EQ.0.OR.LOOKD(FLNM1).EQ.0)GO TO 100
07410	CC  NOT YET!	IF(FLNM1.EQ.0.OR.LOOKU(FLNM1).EQ.0)GO TO 100
07455	C  LOOKS UP NAME.DAT
07500		IF(FLNM.NE.FLNM1)GO TO 2151
07600		OLD=0
07700	4281	TYPE 40,B
07750		IF(PLTALL)GO TO 5402
07800		GO TO 1402
08000	2151	FLNM=FLNM1
08100		CALL READ1
08900	3402	LX=0
08905		TYPE 40,B
08910		IF(PLTALL)GO TO 402
08955	C  "SA" WILL PLOT ALL FUNCS IN FILE
09000		JX=-1
09100		IF(B(1,2).NE.' ')GO TO 1402
09200		FNUM1=B(2,1)
09300	C  ONLY ONE FUNC IN FILE.
09400		GO TO 402
09500	1402	TYPE 42
09600		ACCEPT 40,BU
09650		IF(BU.EQ.' ')GO TO 1402
09700		IF(BU.NE.'B')GO TO 380
09730		FLNM=0
09745		JX=0
09760		GO TO 281
09800	380	REREAD 38,FNUM1
09900		IDEL=0
10000	C  LX IS MAIN COUNTER
10100		IF(OLD)GO TO 402
10200		DO 1302 JX=1,10
10300	1302	IF(FNUM1.EQ.FN(JX))GO TO 5402
10400	CC 7/74 WHY WAS THIS HERE????	GO TO 3402
10450		GO TO 100
10500	2202	CALL DPYF(-1,FUNC)
10600	C  -1 SUPRESSES DISPLAY
10700		IF(P.EQ.'P'.OR.P.EQ.'A'.OR.P.EQ.0)GO TO 70
10800		LPTY=3
10900		JSEE=-1
11000		CALL DPY(FUNC,1)
11100		CALL EXIT
11200	70	CALL PLOTIT(FUNC,XA(JX),P)
11210		IF(P.EQ.'P')GO TO 2281
11220		JX=JX+1
11230		IF(B(2,JX).NE.' '.AND.JX.LE.10)GO TO 2202
11400	CC***	GO TO 2281
11450		CALL EXIT
11500	402	CALL READER
11550		IF(JX)GO TO 100
11575	C 6/74  GO BACK IF IT DIDN'T FIND THE FUNC NAME IN THIS FILE.
11600	C  AT THIS POINT LX=TOTAL FUNCS+1
11620	5402	IF(PLTALL)JX=1
11700	1202	IF(ON.NE.'C'.AND.ON.NE.'S'.AND.ON.NE.'D')GO TO 3281
11800		IF(P.EQ.'P'.OR.P.EQ.'L'.OR.P.EQ.'A')GO TO 2202
11900		CALL DPYF(JX,FUNC)
11910		IF(PLTALL.OR.P.EQ.'P'.OR.P.EQ.0)GO TO 2202
12000		IF(ON.EQ.'S')GO TO 2281
12100		IF(ON.EQ.'C')GO TO 1201
12200	1140	TYPE 1139
12300		ACCEPT 40,IDEL
12400		IF(IDEL.EQ.'N')GO TO 2281
12450		IF(IDEL.NE.'Y')GO TO 1140
12500		IDEL=JX
12600		LX=LX-1
12700	C  NOW LX=TOTAL # OF FUNCS.
12800		CALL WRIFUN
12900	1139	FORMAT(' DELETE IT? ',$)
12910	CC2202	CALL PLOTIT(FUNC,XA(JX),P)
12925	CC	IF(P.EQ.'P')GO TO 2281
12940	CC	JX=JX+1
12955	CC	IF(B(2,JX).NE.' '.AND.JX.LE.10)GO TO 1202
12970	CCC  "SA" KEEPS PLOTTING UNTIL NO MORE ARE FOUND
12985	CC	GO TO 2281
13000	3281	X=' '
13100		TYPE 31,XA(JX),X,FN(JX)
13200		JT=4
13300		IF(XA(JX).EQ.'SEG')JT=2
13400		KZ=1
13500		DO 137	K=1,50
13600		KZ=KZ+1
13700		DO 138 L=1,JT
13800	138	A(K,L)=AA(L,K,JX)
13900	137	IF(A(K,1).EQ.999.OR.A(K,2).GE.100)GO TO 4401
14000	
14100	4401	Z=-1
14200		IF(A(K,2).LE.100)GO TO 4403
14300		IF(K.GT.1)GO TO 4404
14400		CALL DPYF(JX,FUNC)
14500		IF(ON.EQ.'R')GO TO 3032
14600		TYPE 4405
14700		A(1,2)=520
14950		GO TO 4201
15000	4404	TYPE 4402
15100	4403	IF(JT.EQ.2)EY='EG'
15200		GO TO 1032
15300	4402	FORMAT('  IT WAS SMOOTHED.')
15400	4405	FORMAT(' CANNOT EDIT CRUNCHED FUNCS.'/)
15500	1000	TYPE 23
15600		ACCEPT 40,BU
15700		IF(BU.EQ.'B')GO TO 281
15800		REREAD 40,X,EY
15900	1032	CALL ZERO(FUNC)
16000	C  CLEARS THE FUNC.
16100		ISMOO=0
16200		IF(EY.EQ.'EG')GO TO 800
16300	151	EY=0
16400		JT=4
16500	C  FOR WRIFUN
16600	15	KT=1
16700	104	IF(Z.EQ.-1.OR.KT.LT.KZ)GO TO 102
16800		IF(Z.EQ.1)GO TO 2032
16900	1041	KZ=0
17000		TYPE 28
17010		Z=0
17055	C:::: 6/74 COLGATE  Z=0
17100		ACCEPT 40,BU
17200		IF(BU.EQ.'B')GO TO 509
17300		REREAD 30,(A(KT,K),K=1,4)
17400	C ACCEPT HARM,AMPL,PHASE,KONSTANT(IF K>100, MULTIPLIES WAVE *(K-100))
17500	102	H=A(KT,1)
17600		IF(H.EQ.0.OR.H.EQ.999.)GO TO 2200
17700	C   999 ENDS 'READIN' SYNTHS
17800		IF(Z.GT.0)TYPE 371,KT,(A(KT,K),K=1,4)
17900		AMP=A(KT,2)
18000		PH=A(KT,3)
18100		CON=A(KT,4)
18200		CALL SYN(FUNC)
18300		KT=KT+1
18400		IF(KZ.LE.KT)CALL DPY(FUNC,1)
18500		GO TO 104
18510	2201	IF(JT.NE.2.OR.A(KT-1,2).GT.100)GO TO 1201
18520	C  TO USE CURRENT FUNC IN CRUNCH
18532		IF(LX.GT.10)GO TO 204
18545		CALL STORE(10)
18562	C  PUTS FROM A ARRAY TO AA ARRAY
18580		XA(K)='SEG'
18590	CC 6/74 COLGATE--SEE ALSO FUSUB 	CALL DPYF(K,FUNC)
18690		CALL DPYF(10,FUNC)
18700	1201	CALL ZFUNC
18800	C  THIS WILL BE FOR SPECIAL FEATURE PACKAGE
18810		IF(KT.EQ.512)GO TO 2281
18855	C  FOR BACKUP
18860	4201	EY='EG'
18900		KT=2
19000		GO TO 900
19050	2200	IF(KT.LE.1)GO TO 509
19075	C  7/74 COLGATE  BACKUP IF NO INPUT TO SYNTH
19100	CC2200	CALL NORM(FUNC)
19150		CALL NORM(FUNC)
19200	C   NORMALIZES THE FUNCTION
19210	201	CALL DPY(FUNC,1)
19300		IF(BU.EQ.'C')GO TO 2032
19400		IF(ON.EQ.'R')GO TO 3032
19600	204	TYPE 21
19700		IF(EY.EQ.'EG')TYPE 271
19800	C   CHANGE IT?
19900		ACCEPT 40,BU
20000		IF(BU.EQ.'C')GO TO 210
20300		IF(BU.EQ.'F')GO TO 900
20400		IF(BU.EQ.'S')GO TO 7000
20500		IF(BU.EQ.'Z')GO TO 2201
20510	C  TO USE CURRENT FUNC IN CRUNCH
20600		IF(BU.NE.'B')GO TO 2032
20700		IF(EY.EQ.'EG')GO TO 509
20800		GO TO 5091
20900	C   NEXT IS FOR CHANGES ('C' OR <CR>)
21300	2032	TYPE 47
21400		ACCEPT 40,K
21500		REREAD 372,L,X,RF
21600		IF(X.NE.0.OR.RF(1).NE.0)GO TO 211
21700		IF(EY.EQ.'EG')GO TO 204
21800		BU=0
21900		GO TO 1041
22000	211	L=X
22100		IF(K.EQ.'I')GO TO 212
22200		IF(K.NE.'D')GO TO 205
22300	C   JUMP IF NO DELETE
22400		KT=KT-1
22500		DO 209 K=L,KT
22600		DO 209 J=1,4
22700	209	A(K,J)=A(K+1,J)
22800		GO TO 210
22900	205	X=RF(2)
23000		IF(EY.NE.'EG')GO TO 1207
23100		IF(X.GE.A(L+1,2).AND.L.LT.KT-1)GO TO 2032
23200		GO TO 208
23300	212	IF(RF(2).NE.0)GO TO 213
23400		RF(2)=RF(1)
23500		RF(1)=X
23600		L=KT
23700	213	IF(EY.NE.'EG')GO TO 214
23800		X=RF(2)
23900		DO 215 K=1,KT
24000		Y=A(K,2)
24100		IF(X.GT.Y)GO TO 215
24200	C   JUMP IF NOT PAST STEP NUM.
24300		L=K
24400		IF(X.EQ.Y)GO TO 208
24500	C   IF STEP=ANOTHER STEP, IT WORKS LIKE 'C'HANGE.
24600		GO TO 214
24700	215	CONTINUE
24800	214	KT=KT+1
24900		DO 206 K=KT,L,-1
25000		DO 206 J=1,4
25100	206	A(K,J)=A(K-1,J)
25200		GO TO 207
25300	C   TO TYPE OLD NUMBERS
25400	208	IF(X.LE.A(L-1,2).AND.L.GT.1)GO TO 2032
25500	1207	TYPE 371,L,(A(L,K),K=1,4)
25600	207	DO 202 K=1,4
25700	202	A(L,K)=RF(K)
25800	210	KZ=KT
25900		Z=1
26000		GO TO 1032
26100	271	FORMAT('+S=SMOOTH  '$)
26110	C  FOR RENAMES
26140	3032	Z=-1
26170		GO TO 901
26200	900	TYPE 41
26300	C  ADD TO EXISTING FILE
26400		ISKP=0
26500		ACCEPT 40,Z
26600	9000	IF(Z.EQ.'B')GO TO 204
26650		IF(Z.NE.'Y'.AND.Z.NE.'N')GO TO 900
26700		TYPE 25
26800		ACCEPT 38,FLNM
26810		IF(FLNM.EQ.' '.AND.FLNM1.NE.' ')FLNM=FLNM1
26858		IF(FLNM.EQ.'B'.OR.FLNM.EQ.' ')GO TO 204
26900	CC*** NOT YET!	IF(LOOKU(FLNM))GO TO 902
26927	C  LOOKS UP NAME.DAT  (NOT .FUN AS YET)
26954		IF(LOOKD(FLNM))GO TO 902
27002		IF(Z.NE.'N')GO TO 900
27050	C  LOOKD CHECKS ON LOOK-UP
27100	901	JT=4
27200		IF(EY.EQ.'EG')JT=2
27250		IDEL=0
27300		CALL WRIFUN
27400		GO TO 900
27500	C  COMES BACK IF NO ROOM IN FILE FOR NEW FUNC.
27600	
27610	902	IF(Z.NE.'N')GO TO 901
27625		TYPE 381,FLNM
27640		ACCEPT 40,Z
27655		IF(Z.EQ.'Y')GO TO 903
27670		GO TO 9000
27675	903	Z='N'
27680		GO TO 901
27682	C  7/74 COLGATE  NOW WILL REALLY WRITE OVER A FILE!
27685	381	FORMAT(/9X'WRITE OVER ',A5,'.DAT?  ',$)
27700	161	DO 261 K=1,512
27800	261	FUNC(K)=EXP((1-K)/STEP)
27900		KT=2
28000		XP=-1
28100		IF(H.NE.0)GO TO 7009
28200	C  H≠0 = NO NORMALIZATION OF XPONTL
28300		X=FUNC(512)
28400		DO 361 K=1,512
28500	361	FUNC(K)=FUNC(K)-(K-1)/511.*X
28600		GO TO 7009
28700	800	IF(XP)GO TO 510
28800		X=0
28900		IK=0
29000		JT=2
29100	C  JT AND EY SEEM TO PERFORM THE SAME FUNCTIONS??
29200		Y=0
29300		KT=1
29400	504	IF(KT.GE.KZ)GO TO 510
29500		AMP=A(KT,1)
29600	5008	STEP=A(KT,2)
29700		IF(STEP.LE.A(KT-1,2).AND.KT.GT.1)GO TO 509
29800	C   SO IT CAN'T GO BACKWARDS
29900		GO TO 5071
30000	611	FORMAT(' NO MORE THAN 50 SEGS'/)
30100	610	TYPE 611
30200	509	KT=KT-1
30300	5091	IF(KT.LT.1)GO TO 281
30400		GO TO 210
30500	510	IF(KT.EQ.1)TYPE 48
30600		TYPE 26,KT
30700		KZ=0
30800		ACCEPT 40,BU
30900		IF(BU.EQ.'B')GO TO 509
31000	61	REREAD 30,AMP,STEP,H
31100		IF(STEP.LT.1)STEP=1
31200		IF(BU.EQ.'X')GO TO 161
31300	C  TYPE 'X' FOR EXPON. FUNC. + DECAY FACTOR, +1 = NO NORM.
31400	C  WE START WITH STEP 1 (NOT 0)
31500	5071	IF(KT.GT.50)GO TO 610
31600	C   TOO MANY SEGS
31700		IF(Z.GT.0)TYPE 371,KT,AMP,STEP
31800		IF(STEP.GT.100)STEP=100
31900		STPS=STEP-X
32000		IF(STPS.LE.0.AND.KT.NE.1)GO TO 504
32100	C   SO IT CAN'T BACKUP HERE
32200		IS=STPS
32300		IF(STEP.LE.1.)Y=AMP
32400	CC COLGATE 6/74	DIF=(AMP-Y)/STPS
32420		IF(IS.NE.0)DIF=(AMP-Y)/STPS
32500		IJ=STPS*5.12
32700	203	DO 2031 K=1,IJ
32800	2031	FUNC(K+IK)=Y+DIF*K/5.12
32900	C   100 STEPS ARE CONVERTED HERE TO 512
33000		IK=IK+IJ
33100	12	Y=AMP
33200		X=STEP
33300		A(KT,1)=Y
33400		A(KT,2)=X
33500	7001	KT=KT+1
33600	C   KT COUNTS SEGMENTS
33700		IF(STEP.LT.100)GO TO 504
33800		GO TO 201
33900	
34000	
34100	7000	IF(ISMOO)GO TO 201
34200		IF(KT.LE.20)GO TO 7007
34300		TYPE 7008
34400		GO TO 509
34500	7008	FORMAT(' NO MORE THAN 20 SEGS IN CURVES'/)
34600	7007	CALL SSS(A,KT-1,FUNC)
34700	C   DRAWS GRID 2
34800	7009	A(KT-1,2)=520
34900		ISMOO=-1
35000	C  SO YOU CAN'T COME BACK 2 TIMES
35100		GO TO 201
35200		END
00100		SUBROUTINE WRIFUN
00200		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
00300		1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
00400		COMMON FUNC(512),F2(512),K,I
00500		DATA ARY/'ARRAY'/,R999/999.0/
00600	24	FORMAT(' TYPE FUNCTION NAME   '$)
00800	34	FORMAT(A5,'(',A5,');',A5)
00900	35	FORMAT(1XA5,'IN FILE "',A5,'.DAT"'/)
01000	37	FORMAT(8F10.4)
01100	39	FORMAT(A5,10(A1,A3))
01150	391	FORMAT(A3)
01200	390	FORMAT(A1)
01300	43	FORMAT(' NO ROOM IN FILE  "',A5,'.DAT"')
01400	44	FORMAT(' FUNCTIONS ALREADY IN FILE - ',A5)
01500	45	FORMAT('(512);')
01600	
01650		MX=0
01700		IF(IDEL.NE.0)GO TO 292
01800	C  FOR DELETIONS
01900		IF(Z.EQ.'N')GO TO 912
02000		IF(FLNM.EQ.FLNM1)GO TO 1922
02100	C  JUMP IF THAT FILE IS NOW IN CORE
02200	CC	REWIND 1
02300	CC	CALL IFILE(1,FLNM)
02400	CC	READ(1,39),X,B
02450		CALL READ1
02475	1922	IF(Z.EQ.'N')GO TO 912
02500	CC COLGATE 7/741922	TYPE 44,FLNM
02550		TYPE 44,FLNM
02600	C  FUNCS. IN FILE
02700		TYPE 39,MX,B
02800	912	TYPE 24
02900		ACCEPT 390,FNUM
02905		IF(FNUM.EQ.'B')RETURN
02907	C  FOR BACKUP
02910		IF(FNUM.EQ.' ')GO TO 1922
02912		REREAD 391,FNUM
02915		IF(Z.EQ.'N')GO TO 911
02920		IF(Z.NE.-1)GO TO 90
02930	C JUMP IF .NE. 'RENAME'
02931	C 7/74 COLGATE
02932		DO 30 K=1,LX-1
02933		IF(K.EQ.JX.OR.FN(K).NE.FNUM)GO TO 30
02934		TYPE 31
02935		CALL EXIT
02936	31	FORMAT(/' FUNC NAME IN USE!')
02937	30	CONTINUE
02940		B(2,JX)=FNUM
02950		FN(JX)=FNUM
02955		LX=LX-1
02960	CC	MX=127
02970		GO TO 1906
03000	90	IF(FLNM.EQ.FLNM1)GO TO 1090
03100		FNUM1=0
03200		LX=0
03400	C  TO PUT NEW FUNC IN OLD FILE
03500		CALL READER
03600	1090	JX=0
03700		MX=LX
03800		DO 20 K=1,LX-1
03900		IF(FNUM.NE.FN(K))GO TO 20
04000		JX=K
04100		LX=LX-1
04200		GO TO 21
04300	20	CONTINUE
04400	210	JX=LX
04500	C  JX=LX IF FNUM WAS NOT FOUND
04600		IF(JX.GT.10)GO TO 193
04700	21	FN(JX)=FNUM
04800		X='SEG'
04900		IF(J.EQ.4)X='SYNTH'
05000		XA(JX)=X
05100		CALL STORE(JX)
05500		IF(J.EQ.2)GO TO 1192
05600		AA(1,KT,JX)=999
05700		GO TO 192
05800	1192	IF(A(KT-1,2).EQ.100)GO TO 192
05900	C  JUMP IF NO SMOOTHING
06100		DO 2192 K=1,512
06200	2192	AA(K,KT,JX)=FUNC(K)
06500	
06900	192	IF(JX.NE.1)B(1,JX)=','
07000		B(2,JX)=FNUM
07100		GO TO 1906
09500	193	TYPE 43,FLNM
09600	C  NO ROOM IN FILE.
09800		RETURN
09900	C  NEW FILE
10400	911	LX=1
10500		DO 94 K=1,20
10700	94	B(K,1)=' '
10850		GO TO 210
10900	C  CLEARS B FOR NEW, SINGLE ITEM.
12130	292	IF(IDEL.EQ.10)GO TO 932
12141		DO 931 K=IDEL,LX-1
12152	CC	FN(K)=FN(K+1)
12163	931	B(2,K)=B(2,K+1)
12174	932	B(1,LX)=' '
12185		B(2,LX)=' '
12200	1906	REWIND 1
12210		IF(Z.EQ.'N'.OR.IDEL.GT.0)GO TO 22
12220		DO 25 K=1,LX
12225		IF(K.GT.1.AND.B(1,K).NE.',')GO TO 26
12230		X=B(2,K)
12240		IF(X.NE.' '.AND.X.EQ.FN(K))GO TO 25
12250	26	TYPE 23
12260		RETURN
12270	23	FORMAT(/' CONFUSION IN THIS FILE. TRY ANOTHER! '/)
12280	25	CONTINUE
12300	22	CALL OFILE(1,FLNM)
12350	CC  NOT YET! 22	CALL OFLE(1,FLNM,'.FUN')
12375	C  COLGATE OFILE REPLACEMENT.  ALL FUNC FILES WILL BE '.FUN'.
12400		WRITE(1,39),ARY,B
12500		WRITE(1,45)
13100	69	NX=0
13200	1905	IF(NX.EQ.LX)GO TO 904
13250	C  LX=TOTAL # OF FUNCS
13300		NX=NX+1
13400		IF(IDEL.EQ.NX)GO TO 1905
13431	C  SO THAT DATA MUST ALWAYS BE READ FROM DSK AFTER A DEL.
13450	CC1	YA(NX)=' '
13460	CC	IF(XA(NX).EQ.'SYNTH')YA(NX)='   99'
13500	CC	WRITE(1,34),XA(NX),FN(NX),YA(NX)
13600	1	J=4
13610		X='   99'
13620		IF(XA(NX).NE.'SEG')GO TO 68
13630		J=2
13640		X=' '
13650	68	WRITE(1,34),XA(NX),FN(NX),X
13800		JX=0
13900	2905	JX=JX+1
14000		IF(J.EQ.2)GO TO 3905
14100		IF(AA(1,JX,NX).EQ.999)GO TO 5905
14200	C  FOUND END OF A SYNTH
14300		WRITE(1,37),(AA(K,JX,NX),K=1,4)
14400		GO TO 2905
14500	5905	WRITE(1,37)R999
14600		GO TO 1905
14650	3905	X=AA(2,JX,NX)
14700		WRITE(1,37),AA(1,JX,NX),X
14800		IF(X.EQ.100)GO TO 1905
14900	C  FOUND END OF A SEG
15000		IF(X.LT.100)GO TO 2905
15350		WRITE(1,37)(AA(K,JX+1,NX),K=1,512)
15400		GO TO 1905
15500	904	TYPE 39,MX,B
16000		IF(IDEL.EQ.0)TYPE 35,FNUM,FLNM
16035		IF(IDEL.NE.0)FLNM=0
16050		LX=LX+1
16075	C  FOR RESTARTS
16175		CALL EXIT
16700		END
16710	
16800		SUBROUTINE READER
16900		COMMON/LN/LINE
17000		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
17100		1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
17200		COMMON FUNC(512),F2(512),K,I
17300	37	FORMAT(8F)
17400	38	FORMAT(3(A5,A1))
17500	380	FORMAT(I,3(A5,A1))
17600	39	FORMAT(9A5)
17700		READ (1,39),K,K,AK
17800	C  READS "(512);"
17900	C  LX IS MAIN COUNTER
18000	401	LX=LX+1
18100	1	IF(LINE.EQ.0)READ(1,38,END=4401)XA(LX),Y,FN(LX),H,H
18200		IF(LINE)READ(1,380,END=4401)K,XA(LX),Y,FN(LX),H,H
18300		IF(XA(LX).GE.0)GO TO 1
18400	C  TO FIND EOF AFTER COPY SCREWUPS
18500		IF(FNUM1.EQ.FN(LX))JX=LX
18600	C  JX TELLS WHERE TO FIND FUNCTION TO BE LOOKED AT.
18700	C  XA(LX) IS FUNC. TYPE (SEG OR SYNTH)
18800		X=0
18900		N=4
19000		IF(XA(LX).EQ.'SEG')N=2
19100		KX=0
19200	C  KX IS LOCAL COUNTER
19300	1401	IF(X.EQ.100)GO TO 401
19400		KX=KX+1
19500		IF(LINE.EQ.0)READ(1,37),(AA(K,KX,LX),K=1,N)
19600		IF(LINE)READ(1,37)AK,(AA(K,KX,LX),K=1,N)
19700		IF(N.EQ.2)GO TO 2401
19800		IF(AA(1,KX,LX).EQ.999)GO TO 401
19900	C  FOUND END OF A SYNTH
20000		GO TO 1401
20100	2401	X=AA(2,KX,LX)
20200		IF(X.LE.100)GO TO 1401
20300	C  NEXT IS FOR SMOOTHED SEGS
20500		N=KX+1
20505		IF(LINE)GO TO 2
20600		READ(1,37)(AA(K,N,LX),K=1,512)
20700		GO TO 401
20710	370	FORMAT(9F)
20800	2	DO 3 K=1,512,8
20833	3	READ(1,370)AK,(AA(KX,N,LX),KX=K,K+7)
20866		GO TO 401
20900	4401	RETURN
21000		END
21100	
21200	
21300		SUBROUTINE READ1
21400	C  READS FIRST LINE OF FILE ONLY
21500		COMMON/LN/LINE
21600		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
21700		1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
21800	2151	REWIND 1
21900		CALL IFILE(1,FLNM)
21950	CC  NOT YET!	CALL IFLE(1,FLNM,'.FUN')
22000		READ (1,39),X,B
22100		LINE=0
22200		IF(X)RETURN
22300		LINE=-1
22400	C  FOUND LN #S (CAN'T READ SMOOTHS 'THO)
22500		REREAD 390,LX,X,B
22600		RETURN
22700	39	FORMAT(A5,10(A1,A3))
22800	390	FORMAT(I,A5,10(A1,A3))
22900		END
23000	
23100		SUBROUTINE STORE(N)
23200		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
23300		1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
25000		DO 3090 K=1,KT-1
25100		DO 3090 L=1,J
25200	3090	AA(L,K,N)=A(K,L)
25300		RETURN
25400		END
00100		SUBROUTINE ZFUNC
00200		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
00300		1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
00400		COMMON FUNC(512),F2(512),K,I
00500	
00600	43	TYPE 1
00700		ACCEPT 100,MA,C
00720		IF(MA.NE.'B')GO TO 76
00740	430	KT=512
00760	C  FOR BACKUP
00780		RETURN
00900	76	IF(MA.NE.'A'.AND.MA.NE.'M')GO TO 73
00950	75	TYPE 39,B
01000		TYPE 2
01100		ACCEPT 3,FNM2
01150		IF(FNM2.EQ.'B')GO TO 43
03000	40	DO 4 K=1,10
03100	5	IF(FNM2.NE.FN(K))GO TO 4
03200		N2=K
03300		GO TO 72
03400	4	CONTINUE
03500		TYPE 74
03600		GO TO 75
03700	74	FORMAT(' FUNCTION NOT FOUND '/)
03800	72	CALL DPYF(N2,F2)
03910	7	TYPE 60
03940		ACCEPT 100,K
03970		IF(K.EQ.'B'.OR.K.EQ.'N')GO TO 15
03980		IF(MA.EQ.'M')GO TO 102
04000	70	TYPE 10
04100		ACCEPT 11,R,R2
04150		REREAD 100,K
04175		IF(K.EQ.'B')GO TO 75
04200		IF(R2.EQ.0)R2=1
04300		IF(R.EQ.0)R=1
04400		DO 13 K=1,512
04450		X=FUNC(K)
04500		FUNC(K)=FUNC(K)*R+F2(K)*R2+C
04550	13	F2(K)=X
04600		GO TO 104
04700	73	IF(MA.NE.'C')GO TO 44
04716		DO 45 K=1,512
04732		F2(K)=FUNC(K)
04748	45	FUNC(K)=FUNC(K)+C
04764		GO TO 104
04780	44	IF(MA.NE.'I')GO TO 46
04796		DO 47 K=1,512
04812		F2(K)=FUNC(K)
04828	47	FUNC(K)=C-FUNC(K)
04844		GO TO 104
04860	46	IF(MA.NE.'R')GO TO 75
04876	48	DO 50 K=1,512
04892	50	F2(K)=FUNC(513-K)
04908		DO 51 K=1,512
04924		X=FUNC(K)
04940		FUNC(K)=F2(K)+C
04956	51	F2(K)=X
04972		GO TO 104
05000	102	DO 103 K=1,512
05050		X=FUNC(K)
05100		FUNC(K)=FUNC(K)*F2(K)+C
05150	103	F2(K)=X
05200	104	A(1,2)=520
05300		CALL NORM(FUNC)
05400	C   NORMALIZES THE FUNCTION
05500		CALL DPY(FUNC,1)
05600		TYPE 6
05700		ACCEPT 100,K
05800		IF(K.EQ.'M')GO TO 43
05900		IF(K.NE.'B')RETURN
05910		DO 14 K=1,512
05920	14	FUNC(K)=F2(K)
05940	15	CALL DPY(FUNC,1)
05950		GO TO 43
06000	1	FORMAT
06050	     1(' A(DD), M(ULT), R(ETRO), I(NVRT), OR C,N (=ADD CONSTANT N) ',$)
06100	100	FORMAT(A1,F)
06200	2	FORMAT(' 2ND FUNC? ',$)
06300	3	FORMAT(A3)
06400	10	FORMAT(' TYPE RATIO (E.G. 1,2) ',$)
06410	39	FORMAT(10(A1,A3))
06500	11	FORMAT(2F)
06600	6	FORMAT(' F(INISH), OR M(ORE)?  ',$)
06650	60	FORMAT(' GO ON?  ',$)
06700		END
06800	
06900		SUBROUTINE DPYF(N,F)
07000		COMMON/S/H,AMP,CON,PH
07100		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
07200		1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
07300		DIMENSION F(1)
07305		NODPY=-1
07310		IF(N.GT.0)GO TO 8
07320		N=JX
07330		NODPY=0
07400	CC COLGATE 6/74--SEE MAIN AT 1201-18	IF(XA(N).EQ.'SEG')GO TO 5
07410	8	IF(XA(N).NE.'SYNTH')GO TO 5
07500		CALL ZERO(F)
07600		K=1
07700	1	AMP=AA(2,K,N)
07800		H=AA(1,K,N)
07900		PH=AA(3,K,N)
08000		CON=AA(4,K,N)
08100		CALL SYN(F)
08200		K=K+1
08300		IF(AA(1,K,N).NE.999)GO TO 1
08400		CALL NORM(F)
08500		GO TO 4
08800	
08900	5	K=1
08920		G=AA(2,1,N)
09000		IF(G.EQ.520)GO TO 6
09010		J=1
09020		IF(G.LE.1)GO TO 22
09030		Y=0
09040		K=0
09045	C  FOR START BEYOND STEP 1 - ASSUMES A 0,1.
09050		GO TO 2
09100	22	Y=AA(1,1,N)
09300	2	K=K+1
09400		M=AA(2,K,N)*5.12+.5
09500		IF(M.GT.512)GO TO 6
09600		G=AA(1,K,N)
09700		Z=G-Y
09800		H=M-J+1
09850		IF(H.LT.1)H=1
09900		NN=0
10000		DO 3 L=J,M
10100		F(L)=(NN*Z)/H+Y
10200	3	NN=NN+1
10300		IF(M.EQ.512)GO TO 4
10400		Y=G
10500		J=M+1
10600		GO TO 2
10700	C  FOR LONG FUNCS.
10800	6	L=K+1
10900		DO 7 M=1,512
11000	7	F(M)=AA(M,L,N)
11100	4	IF(NODPY)CALL DPY(F,-1)
11110	C  NODPY=0 IS FOR PLOTTER AND LPT
11200	C  NOW FUNCTION IS FULL AND DISPLAYED
11300		RETURN
11400		END
11500	
11600		SUBROUTINE SYN(F)
11700		COMMON/S/H,AMP,CON,PH
11800		DIMENSION F(1)
11900		DATA FAC/0.703125/,FACP/1.422222/
12000		X=PH*FACP+1.0
12100	C  PHASE IS IN DEGREES (0 - 360)
12200	2016	DO 17 L=1,512
12300		XL=SIND(X*FAC)*AMP+CON
12400		IF(CON.LT.100.0)GO TO 1
12500		F(L)=(XL-100.)*F(L)
12600		GO TO 2
12700	1	F(L)=F(L)+XL
12800	C   NORMALIZES THE FUNCTION
12900	2	X=X+H
13000	17	IF(X.GT.512.)X=X-512.
13100		RETURN
13200		END
13300	
13400		SUBROUTINE ZERO(F)
13500		DIMENSION F(1)
13600		DO 1 K=1,512
13700	1	F(K)=0
13800		RETURN
13900		END
14000	
14100		SUBROUTINE NORM(F)
14200		DIMENSION F(1)
14300		X=F(1)
14400	C   NORMALIZES THE FUNCTION
14500		DO 19 K=2,512
14600		XK=ABS(F(K))
14700	19	IF(X.LT.XK)X=XK
14800		DO 20 K=1,512
14900	20	F(K)=F(K)/X
15000		RETURN
15100		END
00100	C  ********** DISPLAY OR PLOT OUTPUT **********
00200		SUBROUTINE DPY(F,IY)
00300		DIMENSION H(120)
00400		COMMON/LT/LPTY,JSEE
00500		DIMENSION F(1)
00600		DATA Q/'X'/
00700		IF(JSEE)GO TO 1
00800		TYPE 2
00900		ACCEPT 3,N
01000		IF(N.NE.'Y')RETURN
01100	1	M=72
01200		JR=12
01300		NN=23
01400		IF(LPTY.EQ.5)GO TO 7
01500		M=120
01600		JR=26
01700		NN=51
01800	7	RH=512.0/M
01900		T=1
02000		S=2.0/NN+.001
02100		DO 4 K=1,NN
02200		R=1.-K*S
02300		H(1)='!'
02400		A=' '
02500		IF(K.EQ.JR)A='-'
02600	6	DO 11 L=2,M
02700	11	H(L)=A
02800		J=1
02900		RJ=1
03000	12	DO 9 L=1,M
03100		A=F(J)
03200		IF(A.GT.R.AND.A.LE.T)H(L)=Q
03300		RJ=RJ+RH
03400	9	J=RJ
03500		T=R
03600	4	WRITE(LPTY,20)(H(L),L=1,M)
03700		IF(LPTY.NE.5)RETURN
03800		TYPE 5
03900		ACCEPT 3,N
04000		RETURN
04100	20	FORMAT(1X120A1)
04200	2	FORMAT(' SEE IT? '$)
04300	3	FORMAT(A1)
04400	5	FORMAT(' <CR>=CONTINUE'$)
04500		END
04600	
04700		SUBROUTINE PLOTIT(FUNC,EY,P)
04800		COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
04900		1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
05000		DIMENSION FUNC(1)
05100		IF(P.EQ.'P')GO TO 1
05200		IF(P.EQ.0)GO TO 4
05300		Y=1
05400		X=2.
05500	CC	IF(P.NE.'X')GO TO 6
05600	CC	X=1.5
05700	CC	Y=.5
05800	6	CALL PLOTS(K)
05900		P=0
06000		GO TO 40
06100	1	TYPE 2
06200		CALL PLOTS(K)
06300		ACCEPT 3,X
06400		IF(X.EQ.0)X=SZX
06500		IF(X.EQ.0)X=1.
06600		SZX=X
06700	40	SZ=X/5.12
06710		CALL PLOT(0,17.*SZ,-3)
06755	C  ABOVE FOR COLGATE PLOTTER.
06800	41	S=0
06900		J=1
07000		RJK=X/8.
07100		CALL SYMBOL(SZ,4.*SZ,RJK,FLNM,0,5)
07200	4	CALL SYMBOL(SZ,-3.*SZ,RJK,B(2,JX),0,3)
07300		CALL PLOT(5.12*SZ,0.,3)
07400		CALL PLOT(0.,0.,2)
07500		CALL PLOT(0.,-2.*SZ,3)
07600		CALL PLOT(0.,2.*SZ,2)
07700	
07800	72	CALL PLOT(.01*SZ,FUNC(1)*2.*SZ,3)
07900		DO 73 K=2,512
08000		R=K/100.0
08100	73	CALL PLOT(R*SZ,FUNC(K)*2.*SZ,2)
08200		T=0
08300		Q=Y+5*SZ
08400		IF(J.NE.5)GO TO 5
08500		Q=-S
08600		T=-7*SZ
08700	5	CALL PLOT(Q,T,-3)
08800		S=S+Q
08900		J=J+1
09000		RETURN
09100	
09200	2	FORMAT(' TYPE SIZE - '$)
09300	3	FORMAT(F)
09400		END
	SUBROUTINE SSS(VV,N1,A1)
	DIMENSION V(50,4),A1(512),C(30,4),YP(30),J(30),NX(3),KA(14),K(9)
	DIMENSION VV(50,4)
	EQUIVALENCE(K1,K(1)),(K2,K(2)),(K3,K(3)),(K4,K(4)),(K5,K(5)),
     1	(K6,K(6)),(K7,K(7)),(K8,K(8)),(K9,K(9))
	DATA KA/1,2,2,1,1,2,1,1,0,2,1,-1,0,1/,DX/.00001/
	IF(VV(1,2).EQ.0) VV(1,2)=1
	DO 5 I=1,30
	DO 5 L=1,2
5	V(I,L)=VV(I,L)
	NX(1)=N1
698	NX(2)=NX(1)-1
	DO 10 I=1,NX(1)
10	V(I,2)=(V(I,2)-1)/99.
	DO 20 I=2,NX(2)
	JX=I+1
	JZ=I-1
	YP(I)=(V(JX,1)-V(JZ,1))/(V(JX,2)-V(JZ,2))
20	IF((V(JX,1)-V(I,1))*(V(I,1)-V(JZ,1)).LE.0) YP(I)=0
	DO 22 I=1,9
22	K(I)=KA(I)
	KOUNT=0
21	KOUNT=KOUNT+1
	V1=V(K2,1)-V(K1,1)
	V2=V(K2,2)-V(K1,2)
802	IF((YP(K2)-V1/V2)*(V(K3,1)-V(K4,1)).GT.0) GO TO 30
24	Z=V(K2,K5)+(V(K1,K6)-V(K2,K6))*YP(K2)**K7
	IF(YP(K2)**2.LT.DX.AND.V1**2.LT.DX) GO TO 36
	IF(YP(K2)**2.LT.DX) GO TO 38
	D1=V(K2,K5)-Z
806	D2=Z-V(K1,K5)
	ZZ=(V(K1,K6)*D2+V(K2,K6)*D1)/(D1+D2)
808	YP(K1)=(ZZ*K9+V(K2,1)*K8-V(K1,1))/
     1	(ZZ*K8+V(K2,2)*K9-V(K1,2))
	GO TO 40
30	DO 32 I=5,9
32	K(I)=KA(I+5)
	GO TO 24
36	YP(K1)=0
	GO TO 40
38	YP(K1)=-100
	IF(KOUNT.EQ.2) GO TO 39
	IF(V(K2,1).GT.V(K1,1)) YP(K1)=100
	GO TO 40
39	IF(V(K2,1).LT.V(K1,1)) YP(K1)=100
40	IF(KOUNT.EQ.2) GO TO 50
	DO 42 I=1,2
	K(I)=NX(I)
42	K(I+2)=K(I)     
	DO 44 I=5,9
44	K(I)=KA(I)
	GO TO 21
50	NX(3)=NX(2)-1
	N=1
52	N=N+1
	IF(N.GT.NX(3)) GO TO 92
	JX=N+1
	V1=V(JX,1)-V(N,1)
	V2=V(JX,2)-V(N,2)
	Y1=YP(N)-YP(JX)
	IF(Y1**2.LT.DX.AND.V1**2.GT.DX) GO TO 720
710	X=(V1-YP(JX)*V(JX,2)+YP(N)*V(N,2))/Y1                   
715	IF(X.GE.V(N,2).AND.X.LE.V(JX,2)) GO TO 52      
	IF(Y1**2.LT.DX.AND.V1**2.LT.DX) GO TO 52
720	DO 120 I=NX(1),JX,-1
	JZ=I+1
	V(JZ,2)=V(I,2)
	V(JZ,1)=V(I,1)
120	YP(JZ)=YP(I)
	YP(JX)=.5*V1/V2
	IF(V1*(YP(N)-V1/V2).LE.0) YP(N+1)=4*YP(JX)
	V(JX,2)=.5*(V(N+2,2)+V(N,2))
	V(JX,1)=.5*(V(N+2,1)+V(N,1))
	N=JX
	DO 88 L=1,3
88	NX(L)=NX(L)+1
  	GO TO 52
92	DO 140 I=1,NX(2)
	JX=I+1
	W0=YP(I)
	W1=YP(JX)
	W2=V(JX,2)-V(I,2)
	W3=V(JX,1)-V(I,1)
	C(I,1)=(W2*(W0+W1)-2*W3)/(W0-W1)
	C(I,2)=W2-C(I,1)
	C(I,4)=W0*C(I,2)
140	C(I,3)=-C(I,4)+W3
730	DO 150 I=1,NX(1)
150	J(I)=511*V(I,2)+1
740	DO 160 I=1,NX(2)
	L1=J(I)+1
	IF(I.EQ.1) L1=1
	ZZ=C(I,2)
	XX=C(I,1)
	L2=J(I+1)
750	DO 160 L=L1,L2
	X=(FLOAT(L)-1.)/511.
	IF(XX**2.LT.DX) GO TO 155
	ZX=.5*SQRT(ZZ**2-4*XX*(V(I,2)-X))/XX
	T1=-.5*ZZ/XX+ZX
	T2=T1-2*ZX
	IF(T2.GT.-DX.AND.T2.LT.(1+DX)) T1=T2
155	IF(XX**2.LT.DX) T1=-(V(I,2)-X)/ZZ
160   	A1(L)=C(I,3)*T1**2+C(I,4)*T1+V(I,1)
770	END